home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / expr.scm < prev    next >
Encoding:
Text File  |  1991-06-10  |  3.9 KB  |  175 lines
  1. ;==============================================================================
  2. ; Expressions
  3. ;
  4. ; Code for recognizing, destructuring, and checking the syntax of forms.
  5.  
  6. (define (literal? x)
  7.   (or (number? x) (string? x) (boolean? x) (char? x)))
  8.  
  9.  
  10. (define syntax-checkers
  11.   (make-vector number-of-classes (lambda (form) form #t)))
  12.  
  13. (define (define-syntax-checker class proc)
  14.   (vector-set! syntax-checkers class proc))
  15.  
  16. (define (check-special-form-syntax class form)
  17.   ((vector-ref syntax-checkers class) form))
  18.  
  19.  
  20. ; (let-syntax (<syntax-spec>*) <body>)
  21.  
  22. (define let-syntax-form-dspecs cadr)
  23. (define let-syntax-form-body caddr)
  24.  
  25. (define-syntax-checker class/let-syntax
  26.   (lambda (exp)
  27.     (and (= (careful-length exp) 3)
  28.      (careful-every check-syntax-spec (cadr exp)))))
  29.  
  30. ; (letrec-syntax (<syntax-spec>*) <body>)
  31.  
  32. (define letrec-syntax-form-dspecs let-syntax-form-dspecs)
  33. (define letrec-syntax-form-body   let-syntax-form-body)
  34.  
  35. (define-syntax-checker class/letrec-syntax
  36.   (lambda (exp)
  37.     (and (= (careful-length exp) 3)
  38.      (careful-every check-syntax-spec (cadr exp)))))
  39.  
  40. ; Syntax specs (<name> <form>)
  41.  
  42. (define syntax-spec-name car)
  43. (define syntax-spec-form cadr)
  44.  
  45. (define (check-syntax-spec syntax-spec)
  46.   (and (= (careful-length syntax-spec) 2)
  47.        (name? (syntax-spec-name syntax-spec))))
  48.  
  49. ; (define-syntax <name> <form>)
  50.  
  51. (define define-syntax-syntax-spec cdr)
  52.  
  53. (define-syntax-checker class/define-syntax
  54.   (lambda (form)
  55.     (check-syntax-spec (cdr form))))
  56.  
  57. ; (begin <statement>*)
  58.  
  59. (define begin-form-statements cdr)
  60.  
  61. (define-syntax-checker class/begin
  62.   (lambda (form)
  63.     (>= (careful-length form) 1)))    ;must be a proper list
  64.  
  65.  
  66. ; application
  67.  
  68. (define application-form-procedure car)
  69. (define application-form-arguments cdr)
  70.  
  71.  
  72. ; (lambda (<name>*) <body>)
  73.  
  74. (define lambda-form-formals cadr)
  75. (define lambda-form-body cddr)
  76.  
  77. (define-syntax-checker class/lambda
  78.   (lambda (exp)
  79.     (and (>= (careful-length exp) 3)
  80.      (check-formals (lambda-form-formals exp)))))
  81.  
  82. (define (check-formals formals)
  83.   (or (null? formals)
  84.       (name? formals)
  85.       (and (name? (car formals)) (check-formals (cdr formals)))))
  86.  
  87.  
  88. ; (letrec ((<name> <exp>)) <body>)
  89.  
  90. (define letrec-form-bspecs cadr)
  91. (define letrec-form-body cddr)
  92.  
  93. (define-syntax-checker class/letrec
  94.   (lambda (exp)
  95.     (and (>= (careful-length exp) 3)
  96.      (careful-every (lambda (syntax-spec)
  97.               (and (= (careful-length syntax-spec) 2)
  98.                    (name? (syntax-spec-name syntax-spec))))
  99.             (letrec-form-bspecs exp)))))
  100.  
  101.  
  102. ; (quote <text>)
  103.  
  104. (define quote-form-text cadr)
  105.  
  106. (define-syntax-checker class/quote
  107.   (lambda (exp)
  108.     (= (careful-length exp) 2)))
  109.  
  110.  
  111. ; (if <test> <con> <alt>)
  112.  
  113. (define if-form-test cadr)
  114. (define if-form-consequent caddr)
  115. (define (if-form-alternate? exp)
  116.   (not (null? (cdddr exp))))
  117. (define if-form-alternate cadddr)
  118.  
  119. (define-syntax-checker class/if
  120.   (lambda (exp)
  121.     (let ((len (careful-length exp)))
  122.       (or (= len 3) (= len 4)))))
  123.  
  124.  
  125. ; (set! <lhs> <rhs>)
  126.  
  127. (define set!-form-lhs cadr)
  128. (define set!-form-rhs caddr)
  129.  
  130. (define-syntax-checker class/set!
  131.   (lambda (exp)
  132.     (and (= (careful-length exp) 3)
  133.      (name? (cadr exp)))))
  134.  
  135.  
  136. ; (define name exp) or (define (name . args) . body)
  137.  
  138. (define-syntax-checker class/define
  139.   (lambda (form)
  140.     (and (pair? (cdr form))
  141.      (let ((pat (cadr form)))
  142.        (if (name? pat)
  143.            (= (careful-length form) 3)
  144.            (and (pair? pat)
  145.             (check-formals (cdr pat))
  146.             (>= (careful-length form) 3)))))))
  147.  
  148. (define (define-form-lhs form)
  149.   (let ((pat (cadr form)))
  150.     (if (pair? pat) (car pat) pat)))
  151.  
  152. (define (define-form-rhs form)
  153.   (let ((pat (cadr form)))
  154.     (if (pair? pat)
  155.     `(lambda ,(cdr pat) ,@(cddr form))
  156.     (caddr form))))
  157.  
  158.  
  159. ; Versions of LENGTH and EVERY that do not assume that the lists they are
  160. ; handed are proper.
  161.  
  162. (define (careful-length l)
  163.   (if (null? l)
  164.       0
  165.       (if (pair? l)
  166.       (+ 1 (careful-length (cdr l)))
  167.       -1)))
  168.  
  169. (define (careful-every pred l)
  170.   (if (null? l)
  171.       #t
  172.       (and (pair? l)
  173.        (pred (car l))
  174.        (careful-every pred (cdr l)))))
  175.